home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
The CICA Windows Explosion!
/
The CICA Windows Explosion! - Disc 2.iso
/
programr
/
swtools.zip
/
SWDEMO.PAS
< prev
next >
Wrap
Pascal/Delphi Source File
|
1993-03-09
|
11KB
|
324 lines
program SWToolsDemo;
{ShareWare Tools (c) 1992 Scott Gifford. All Rights Reserved.}
{This program was written in Turbo Pascal for Windows V1.5. I have tried
my best, however, to make it understandable for programmers in all languages
with my comments. If you still don't understand something, or if you have
any type of question about this program, please contact me at one of the
addresses listed under Questions, Problems, and Comments in the SWTools.HLP
file.}
{Thank you for trying SWTools!}
{---Scott.}
{The following command causes a resource file to be included.}
{$r swdemo}
{These units are included in most Windows applications}
uses WObjects,WinTypes,WinProcs,Strings,WinCRT;
const
pw:array[0..8] of char='password'; {program password}
TrialPeriod=30; {Length of trial period}
RegPath:packed array[0..15] of char='swdemo.reg'; {Registration file}
DGBPath:packed array[0..15] of char='swdemo.dgb'; {DateStamp file}
id_register=110; {A button in the DBs}
id_proceed=111; {Another button}
id_quit=112; {Yet another button}
id_DaysLeft=121; {A static from a DB}
id_name=101; {Edit control ID}
id_reg=102; { " " "}
id_quest=103; { " " "}
id_FavColor=104; { " " "}
id_scram=120; {Scramble button}
id_date=121; {MakeDate button}
id_help=122; {help button}
id_QuestBtn=123; {quest button}
id_FavColorBtn=124; {favorite coloe button}
type
Str10=array[0..10] of char; {TPW treats these arrays as pointers to
null-terminated strings}
var {global}
Registered:integer; {1 if registered}
Name, {Registration name}
Quest, {Reg. quest}
FavColor:Str10; {Reg. Favorite color}
{Importing the DLL. If you don't speak TPW fluently, note that PChar
refers to a null-terminated string and PDosStream to a pointer to
a DOS stream. If your language doesn't support either of these, just
use a plain old pointer.}
procedure scramble(what,password,result:PChar;v:integer);
far; external 'SWTOOLS1' index 1;
function CreateDateFile(FileName,password:PChar;v:integer):integer;
far; external 'SWTOOLS1' index 2;
function CreateNewDate(FileName,pw:PChar; v:integer):integer;
far; external 'SWTOOLS1' index 3;
function DaysGoneBy(FileName,password:PChar;v:integer):integer;
far; external 'SWTOOLS1' index 4;
function CheckRegistration(RegFile,Name,PassWord:PChar; more:integer;
var MoreToFollow:PDosStream;v:integer):integer;
far; external 'SWTOOLS1' index 5;
procedure GetRegInfo(MoreFollowing:PDosStream; var ExtraInfo:Str10;v:integer);
far; external 'SWTOOLS1' index 7;
procedure DoneWithInfo(MoreFollowing:PDosStream;v:integer);
far; external 'SWTOOLS1' index 9;
procedure CreateRegistration(RegFile,name,PassWord:PChar; more:integer;
var MoreToFollow:PDosStream;v:integer);
far; external 'SWTOOLS1' index 6;
procedure WriteRegInfo(MoreFollowing:PDosStream; ExtraInfo:PChar;v:integer);
far; external 'SWTOOLS1' index 8;
{The definition for the registration DB}
type
PRegister=^TRegister;
TRegister=object(TDialog)
{The following two methods respond to an id_register and id_quit message
from Windows, sent when the Register and Quit buttons in this DB are
pressed. For the actual values of these, see const section above.}
procedure IDRegister(var msg:TMessage);
virtual id_first + id_register;
procedure IDQuit(var msg:TMessage);
virtual id_first + id_quit;
end;
procedure TRegister.IDRegister(var msg:TMessage);
{Reaction to the Register button being pressed}
{To generate a registration number for yourself, use the Scrambler tool.
For more information, read the help file.}
var
name, {Name from the edit}
ReadReg, {Reg " " " }
RealReg, {Reg the program figured out}
temp:Str10; {The approximate temperature in Geneva, Switzerland}
{also used as a temporary variable}
RegFile:PDosStream; {For disk I/O}
begin
{Retrieve the name and reg number}
GetDlgItemText(HWindow,id_name,name,11);
GetDlgItemText(HWindow,id_reg,ReadReg,11);
{Figure out what the Reg # SHOULD have been}
Scramble(name,pw,RealReg,1);
{Compare it to the one read in}
if StrIComp(ReadReg,RealReg)<>0
then begin
{If they are different,send a message and return to the DB}
MessageBox(HWindow,'That is not the correct registration code',
'Bad Reg #',mb_OK);
exit;
end;
{Otherwise, create a registration file}
CreateRegistration(RegPath,name,pw,1,RegFile,1);
{In addition to the name and reg #, send the quest and favorite color}
GetDlgItemText(HWindow,id_quest,temp,11);
WriteRegInfo(RegFile,temp,1);
GetDlgItemText(HWindow,id_FavColor,temp,11);
WriteRegInfo(RegFile,temp,1);
{ALWAYS REMEMBER TO CALL THIS WHEN DONE WITH THE REG FILE!}
DoneWithInfo(RegFile,1);
{Exit the dialog and return 1}
EndDlg(1);
end;
procedure TRegister.IDQuit(var msg:TMessage);
{Respond to the Quit button by ending the dialog and returning 0}
begin
EndDlg(0);
end;
{The definition for the TimesUp DB, and for the PleaseReg DB}
{The two DBs are so similar, they only need one definition.}
type
PTimesUp=^TTimesUp;
TTimesUp=object(TDialog)
procedure SetUpWindow;
virtual;
procedure IDRegister(var msg:TMessage);
virtual id_first + id_register;
procedure IDQuit(var msg:TMessage);
virtual id_first + id_quit;
end;
procedure TTimesUp.SetUpWindow;
{Changes the static with ID id_DaysLeft to the actual number of days left.}
var
DaysLeft:array[0..2] of char;
begin
Str(DaysGoneBy(DGBPath,pw,1):2,DaysLeft);
Str(TrialPeriod-DaysGoneBy(DGBPath,pw,1):2,DaysLeft);
SetDlgItemText(HWindow,id_daysleft,DaysLeft);
end;
procedure TTimesUp.IDRegister(var msg:TMessage);
{Reacts to the Register button by creating the Register DB.
If it returns 1 (i.e. if they registered), returns a 1 and allows
them to go on with the program. Otherwise, leaves them with
this DB again.}
begin
if Application^.ExecDialog(new(PRegister,init(@self,'REGISTER')))=1 then EndDlg(1);
end;
procedure TTimesUp.IDQuit(var msg:TMessage);
{Reacts to the Quit button by closing the DB and returning a 0}
begin
EndDlg(0);
end;
{Definition for the main window}
type
PDemoWin=^TDemoWin;
TDemoWin=object(TWindow)
constructor init(AParent:PWindowsObject; AName:PChar);
procedure SetUpWindow;
virtual;
procedure IDScram(var msg:TMessage);
virtual id_first + id_scram;
procedure IDDate(var msg:TMessage);
virtual id_first + id_date;
procedure IDQuestBtn(var msg:TMessage);
virtual id_first + id_questBtn;
procedure IDFavColorBtn(var msg:TMessage);
virtual id_first + id_FavColorBtn;
procedure IDHelp(var msg:TMessage);
virtual id_first + id_help;
end;
constructor TDemoWin.init(AParent:PWindowsObject; AName:PChar);
{Creates the window and its buttons}
var
Button:PButton;
begin
TWindow.init(AParent,AName);
{Each of the following commands causes a button to be created.
The parameters are as follows: (parent,ID,title,x,y,width,height,default)}
Button:=new(PButton,init(@self,id_scram,'Scrambler',25,25,100,100,false));
Button:=new(PButton,init(@self,id_date,'MakeDate',125,125,100,100,false));
Button:=new(PButton,init(@self,id_help,'Help',225,225,100,100,false));
Button:=new(PButton,init(@self,id_QuestBtn,'Quest',335,125,100,100,false));
Button:=new(PButton,init(@self,id_FavColorBtn,'Color',435,25,100,100,false));
end;
procedure TDemoWin.SetUpWindow;
{This is the part that most uses the SWTools. Watch closely...}
var
RegFile:PDosStream;
i:integer;
begin
TWindow.SetUpWindow;
{Assume they are not registered}
registered:=0;
{Check registration file, and pass 1 as the More parameter to ask for
more info.}
if CheckRegistration(RegPath,name,pw,1,RegFile,1)=1 then
begin
{If CheckRegistration returns 1, they are registered.}
registered:=1;
{Get more info AND CLOSE REGFILE.}
GetRegInfo(RegFile,quest,1);
GetRegInfo(RegFile,FavColor,1);
DoneWithInfo(RegFile,1);
end
{If they are not registered...}
else if DaysGoneBy(DGBPath,pw,1)>TrialPeriod
{And the trial period is over, execute the TimesUp DB. It will return
1 if they register.}
then if Application^.ExecDialog(new(PTimesUp,init(@self,'TIMESUP')))<>1
then begin
{If they don't register, close the window and exit.}
PostMessage(HWindow,wm_close,0,0);
exit;
end
else registered:=1 {If they do.}
{If they are NOT registered, and the time limit is NOT up.}
else if Application^.ExecDialog(new(PTimesUp,init(@self,'PLEASEREG')))=1
then registered:=1;
{Note that if they register now, their quest and favorite color
won't be recognized until they quit and load it again. To
fix this in your own programs, have the DB notiy you when someone
registered, or something like that.}
end;
{The rest of the program just defines the buttons and sets up the app;
it's pretty self-explanatory, and has very little to do with SWTools.}
procedure TDemoWin.IDScram;
begin
WinExec('scramble.exe',sw_normal);
end;
procedure TDemoWin.IDDate;
begin
WinExec('makedate.exe',sw_normal);
end;
procedure TDemoWin.IDHelp;
begin
WinHelp(HWindow,'swdemo.hlp',help_index,0);
end;
procedure TDemoWin.IDQuestBtn;
begin
MessageBox(HWindow,quest,name,mb_OK);
end;
procedure TDemoWin.IDFavColorBtn;
begin
MessageBox(HWindow,FavColor,name,mb_OK);
end;
type TDemoApp=object(TApplication)
procedure InitMainWindow;
virtual;
end;
procedure TDemoApp.InitMainWindow;
begin
MainWindow:=new(PDemoWin,init(nil,'ShareWare Tools V1.0 Demo'));
end;
var {global}
DemoApp:TDemoApp;
begin {main}
with DemoApp do begin
init('SWTOOLSDEMO');
run;
done;
end;
end.
{Thank you for trying SWTools!}